\ Preprocessor FOOS demo - Copyright 2012 J.L. Bezemer
\ You can redistribute this file and/or modify it under
\ the terms of the GNU General Public License

include lib/memcell.4th                \ for ALLOCATE
include lib/memchar.4th                \ for CALLOCATE
include 4pp/lib/foos.4pp
                                       \ allocate and store a string
: place!                               ( a n addr --)
  >r dup 1+ callocate abort" Out of heap space" >r r@ place r> r> !
;                                      \ free some memory
                                       ( addr --)
: free? @ cfree abort" Cannot free memory" ;

:: two-light                           \ create a two light traffic light
   class
     field:  Red                       \ red color string
     field:  Green                     \ green color string
     field:  State                     \ state of the traffic light
     field:  #lights                   \ number of lights
     method: Switch                    \ change to the next state
     method: Show                      \ show the current state
     method: Destroy                   \ destroy the object
   end-class {

     s" Red"   this -> Red   place!    \ save red light color
     s" Green" this -> Green place!    \ save green light color

     2 this -> #lights !               \ it has two lights
     0 this -> State !                 \ set initial state

     table Config                      \ describe the configuration
       ['] Green ,                     \ pointer to the green color
       ['] Red ,                       \ pointer to the red color
     does> rot th @c + @ count type cr ;
                                       \ show the current color
     ['] Config defines Show           \ assign it to the Show method

     :method {
        this -> State dup @ dup        \ get the current state
        this => Show 1+                \ show it, go to next state
        this -> #lights @ mod swap !   \ and set it
     } ; defines Switch                \ assign it to the Switch method

     :static :Destroy {                \ free the green and red light
        this -> Green free? this -> Red free?
        this free abort" Cannot free object"
     } ; overrides Destroy
   }

   private{ State Config }             \ Config and State are private
;

:: three-light                         \ create a three light traffic light
   extends two-light                   \ based on the two light traffic light
     field: Yellow                     \ add the color Yellow
   end-extends {

     s" Yellow" this -> Yellow place!  \ save yellow light color

     3 this -> #lights !               \ it has three lights

     table Config                      \ describe the configuration
       ['] Green ,                     \ pointer to the green color
       ['] Yellow ,                    \ pointer to the yellow color
       ['] Red ,                       \ pointer to the  color
     does> rot th @c + @ count type cr ;
                                       \ show the current color
     ['] Config defines Show           \ assign it to the Show method

     :method {                         \ free all lights
        this -> Yellow free?           \ destroy the yellow color
        this -> :Destroy               \ destroy all previous colors
     } ; defines Destroy
   }

   private{ Config }                   \ Config is private
;

new two-light DontWalk                 \ define a pedestrian light

." A pedestrian traffic light:" cr cr
DontWalk => Switch                     \ go to the next state four times
DontWalk => Switch
DontWalk => Switch
DontWalk => Switch

DontWalk => Destroy cr                 \ now destroy it

new three-light TrafficLight           \ define a normal light

." A normal traffic light:" cr cr
TrafficLight => Switch                 \ go to the next state four times
TrafficLight => Switch
TrafficLight => Switch
TrafficLight => Switch

TrafficLight => Destroy cr             \ now destroy it
